;;; -*- Mode:LISP; Package:ZWEI; Base:10 -*-

;;; This is the default directory listing routine
(DEFUN DEFAULT-DIRECTORY-LISTER (PATHNAME)
  "Print a directory listing of PATHNAME in the default manner.
Uses the value of *DIRECTORY-SINGLE-FILE-LISTER* on each element of the directory-list."
  (WITH-OPEN-STREAM (STREAM (FS:DIRECTORY-LIST-STREAM PATHNAME))
    (LET ((NILENTRY (SEND STREAM :ENTRY)))
      (IF (CAR NILENTRY)
          (FERROR NIL "First entry returned by a directory-list stream is not for NIL"))
      ;; What directory did we actually read?
      (SETQ PATHNAME (OR (GET NILENTRY :PATHNAME) PATHNAME))
      (FORMAT T "~&~A~%" PATHNAME)
      (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* NILENTRY)
      (DO-FOREVER
        (LET ((ENTRY (SEND STREAM :ENTRY)))
          (OR ENTRY (RETURN))
          (FUNCALL *DIRECTORY-SINGLE-FILE-LISTER* ENTRY)))))
  (FORMAT T "Done.~%"))

;Note that *DIRECTORY-SINGLE-FILE-LISTER* is expected to output lines.

(DEFUN DEFAULT-LIST-ONE-FILE (FILE &OPTIONAL (STREAM *STANDARD-OUTPUT*) &AUX PATHNAME)
  (COND ((NULL (SETQ PATHNAME (CAR FILE)))
         (COND ((GET FILE :DISK-SPACE-DESCRIPTION)
                (SEND STREAM :LINE-OUT (GET FILE :DISK-SPACE-DESCRIPTION)))
               ((GET FILE :PHYSICAL-VOLUME-FREE-BLOCKS)
                (DO ((FREE (GET FILE :PHYSICAL-VOLUME-FREE-BLOCKS) (CDR FREE))
                     (FLAG T NIL))
                    ((NULL FREE) (SEND STREAM :TYO #\NEWLINE))
                 (FORMAT STREAM "~A #~A=~D" (IF FLAG "Free:" ",") (CAAR FREE) (CDAR FREE))))
               (T
                (SEND STREAM :TYO #\NEWLINE))))
        ((TYPEP STREAM 'INTERVAL-STREAM)
         (LET ((STRING (CREATE-LINE 'ART-STRING 128. NIL)))
           (DEFAULT-LIST-ONE-FILE FILE STRING)
           (SEND STREAM :LINE-OUT STRING)))
        ((OR (NULL STREAM) (STRINGP STREAM))
         (LET ((STRING
                 (OR STREAM (MAKE-ARRAY 128. :TYPE 'ART-STRING :LEADER-LENGTH 1))))
           (SETF (FILL-POINTER STRING) 0)
           (ARRAY-INITIALIZE STRING #\SP 0 (ARRAY-LENGTH STRING))
           (VECTOR-PUSH (IF (GET FILE :DELETED) #\D #\SP) STRING)
           (VECTOR-PUSH #\SP STRING)
           (STRING-NCONC STRING (OR (GET FILE :PHYSICAL-VOLUME) ""))
           (SETF (FILL-POINTER STRING) (1+ (MAX 5 (FILL-POINTER STRING))))
           (STRING-NCONC STRING (SEND PATHNAME :STRING-FOR-DIRED))
           (VECTOR-PUSH #\SP STRING)
           (LET ((LINK-TO (GET FILE :LINK-TO)))
             (IF LINK-TO
                 (PROGN (STRING-NCONC STRING "=> " LINK-TO " ")
                        (SETF (FILL-POINTER STRING)
                              (MAX 56. (FILL-POINTER STRING))))
               (progn
               (LET ((LENGTH (GET FILE :LENGTH-IN-BLOCKS)))
                 (SETF (FILL-POINTER STRING)
                       (MAX 39. (FILL-POINTER STRING)))
                 (COND ((NULL LENGTH)
                        (STRING-NCONC STRING "     "))
                       ((> LENGTH 999.)
                        (SETF (FILL-POINTER STRING)
                              (NUMBER-INTO-ARRAY STRING LENGTH 10.
                                                 (FILL-POINTER STRING) 4))
                        (VECTOR-PUSH #\SP STRING))
                       (T
                        (SETF (FILL-POINTER STRING)
                              (MAX 40. (FILL-POINTER STRING)))
                        (SETF (FILL-POINTER STRING)
                              (NUMBER-INTO-ARRAY STRING LENGTH 10.
                                                 (FILL-POINTER STRING) 3))
                        (VECTOR-PUSH #\SP STRING))))
               (LET ((LENGTH (GET FILE :LENGTH-IN-BYTES)))
                 (IF (GET FILE :DIRECTORY)
                     (STRING-NCONC STRING "DIRECTORY")
                   (WHEN LENGTH
                     (SETF (FILL-POINTER STRING)
                           (NUMBER-INTO-ARRAY STRING LENGTH 10.
                                              (FILL-POINTER STRING) 6))
                     (VECTOR-PUSH #\( STRING)
                     (SETF (FILL-POINTER STRING)
                           (NUMBER-INTO-ARRAY STRING (GET FILE :BYTE-SIZE) 10.
                                              (FILL-POINTER STRING)))
                     (VECTOR-PUSH #\) STRING))))
               (SETF (FILL-POINTER STRING)
                     (MAX 55. (FILL-POINTER STRING)))
               (VECTOR-PUSH (COND ((GET FILE :OFFLINE) #\O)
                                  ((GET FILE :NOT-BACKED-UP) #\!)
                                  (T #\SP))
                            STRING))))
           (VECTOR-PUSH (IF (GET FILE :DONT-DELETE) #\@ #\SP) STRING)
           (VECTOR-PUSH (IF (GET FILE :DONT-SUPERSEDE) #\# #\SP) STRING)
           (VECTOR-PUSH (IF (GET FILE :DONT-REAP) #\$ #\SP) STRING)
           (TIME-INTO-ARRAY STRING (GET FILE :CREATION-DATE))
           (LET* ((DATE-LAST-EXPUNGE (GET FILE :DATE-LAST-EXPUNGE))
                  (REFERENCE-DATE (OR DATE-LAST-EXPUNGE (GET FILE :REFERENCE-DATE))))
             (WHEN (NOT (MEMQ REFERENCE-DATE '(NIL :NIL)))  ;AVOID LOSSAGE CAUSED BY
                        ;UNMENTIONABLE THINGS HAPPENING DURING RESTORE-MAGTAPE
               (STRING-NCONC STRING (IF DATE-LAST-EXPUNGE " X=" " ("))
               (TIME-INTO-ARRAY STRING REFERENCE-DATE NIL)
               (OR DATE-LAST-EXPUNGE (STRING-NCONC STRING ")"))))
           (LET ((AUTHOR (GET FILE :AUTHOR)))
             (WHEN (AND AUTHOR (NOT (EQUAL AUTHOR (SEND PATHNAME :DIRECTORY))))
               (SETF (FILL-POINTER STRING)
                     (MAX 80. (FILL-POINTER STRING)))
               (STRING-NCONC STRING AUTHOR)))
           (LET ((READER (GET FILE :READER)))
             (WHEN (AND READER (NOT (EQUAL READER (SEND PATHNAME :DIRECTORY))))
               (SETF (FILL-POINTER STRING)
                     (MAX 85. (FILL-POINTER STRING)))
               (STRING-NCONC STRING READER)))
           STRING))
        (T (FORMAT STREAM "~C ~3A "
                   (IF (GET FILE :DELETED) #\D #\SP)
                   (OR (GET FILE :PHYSICAL-VOLUME) ""))
           (IF (OPERATION-HANDLED-P STREAM :ITEM)
               (SEND STREAM :ITEM 'FILE PATHNAME "~A" (SEND PATHNAME :STRING-FOR-DIRED))
             (SEND STREAM :STRING-OUT (SEND PATHNAME :STRING-FOR-DIRED)))
           (FORMAT STREAM "~20T")
           (LET ((LINK-TO (GET FILE :LINK-TO)))
             (IF LINK-TO
                 (FORMAT STREAM "=> ~A ~40T" LINK-TO)
               (LET ((LENGTH (GET FILE :LENGTH-IN-BLOCKS)))
                 (LET ((*STANDARD-OUTPUT* STREAM))
                   (FORMAT:TAB 23.))
                 (COND ((NULL LENGTH)
                        (LET ((*STANDARD-OUTPUT* STREAM))
                          (FORMAT:TAB 28.)))
                       ((> LENGTH 999.)
                        (FORMAT STREAM "~4D " LENGTH))
                       (T
                        (LET ((*STANDARD-OUTPUT* STREAM))
                          (FORMAT:TAB 24.))
                        (FORMAT STREAM "~3D " LENGTH))))
               (LET ((LENGTH (GET FILE :LENGTH-IN-BYTES)))
                 (IF (GET FILE :DIRECTORY)
                     (PRINC "  DIRECTORY" STREAM)
                   (AND LENGTH
                        (FORMAT STREAM "~6D(~D)" LENGTH (GET FILE :BYTE-SIZE)))))
               (FORMAT STREAM "~39T")
               (SEND STREAM :TYO
                     (COND ((GET FILE :OFFLINE) #\O)
                           ((GET FILE :NOT-BACKED-UP) #\!)
                           (T #\SP)))))
           (SEND STREAM :TYO (IF (GET FILE :DONT-DELETE) #\@ #\SP))
           (SEND STREAM :TYO (IF (GET FILE :DONT-SUPERSEDE) #\# #\SP))
           (SEND STREAM :TYO (IF (GET FILE :DONT-REAP) #\$ #\SP))
           (LET ((CREATION-DATE (GET FILE :CREATION-DATE)))
             (IF CREATION-DATE
                 (MULTIPLE-VALUE-BIND (SECONDS MINUTES HOURS DAY MONTH YEAR)
                     (TIME:DECODE-UNIVERSAL-TIME CREATION-DATE)
                   (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D ~2,'0D:~2,'0D:~2,'0D"
                           MONTH DAY (MOD YEAR 100.) HOURS MINUTES SECONDS))
                 (FORMAT STREAM "~17@T")))
           (LET* ((DATE-LAST-EXPUNGE (GET FILE :DATE-LAST-EXPUNGE))
                  (REFERENCE-DATE (OR DATE-LAST-EXPUNGE (GET FILE :REFERENCE-DATE))))
             (AND (NOT (MEMQ REFERENCE-DATE '(NIL :NIL)))  ;AVOID LOSSAGE CAUSED BY
                        ;UNMENTIONABLE THINGS HAPPENING DURING RESTORE-MAGTAPE
                  (MULTIPLE-VALUE-BIND (NIL NIL NIL DAY MONTH YEAR)
                      (TIME:DECODE-UNIVERSAL-TIME REFERENCE-DATE)
                    (PRINC (IF DATE-LAST-EXPUNGE " X=" " (")
                           STREAM)
                    (FORMAT STREAM "~2,'0D//~2,'0D//~2,'0D" MONTH DAY (MOD YEAR 100.))
                    (OR DATE-LAST-EXPUNGE (PRINC ")" STREAM)))))
           (LET ((AUTHOR (GET FILE :AUTHOR)))
             (AND AUTHOR (NOT (EQUAL AUTHOR (SEND PATHNAME :DIRECTORY)))
                  (FORMAT STREAM "~74T~A" AUTHOR)))
           (LET ((READER (GET FILE :READER)))
             (AND READER (NOT (EQUAL READER (SEND PATHNAME :DIRECTORY)))
                  (FORMAT STREAM "~84T~A" READER)))
           (SEND STREAM :TYO #\NEWLINE))))
